Location: lib, 97 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009
; Placed in the Public Domain
; (write-to-string object)    ==>  string
; (display-to-string object)  ==>  string
; (load-from-library "write-to-string.scm")
; Write the external representation of the given OBJECT to a fresh
; string. WRITE-TO-STRING is like WRITE but writes its output to a
; string instead of an output port. DISPLAY-TO-STRING is like
; DISPLAY but writes its output to a string.
; Example:   (write-to-string '(a 1 #\c #(v) #t "str" "\"s\"" (a . d)))
;              ==>  "(a 1 #\\c #(v) #t \"str\" \"\\\"s\\\"\" (a . d))"
;            (display-to-string '(a 1 #\c #(v) #t "str" "\"s\"" (a . d)))
;              ==>  "(a 1 c #(v) #t str \"s\" (a . d))"

(define (make-string-writer readable)
  (lambda (x)

    (define (stringify-improper-list a first)
        ((pair? a)
          (string-append (if first "" " ")
                         (to-string (car a))
                         (stringify-improper-list (cdr a) #f)))
        ((null? a)
          (string-append " . " (to-string a)))))

    (define (char->string c)
      (if readable
          (let ((v (char->integer c)))
            (cond ((= v 10)
                  ((= v 32)
                  ((or (<= 0 v 31)
                       (> v 126))
                    (string-append "#<unrepresentable character, code="
                                   (number->string v)
                    (string-append "#\\" (string c)))))
          (string c)))

    (define (quote-string s)
        (let q ((si (string->list s))
                (so '()))
          (cond ((null? si)
                  (reverse! so))
                ((char=? #\\ (car si))
                  (q (cdr si) (append (list #\\ #\\) so)))
                ((char=? #\" (car si))
                  (q (cdr si) (append (list #\" #\\) so)))
                  (q (cdr si) (cons (car si) so)))))))

    (define (to-string x)
      (cond ((eq? #t x)
            ((eq? #f x)
            ((symbol? x)
              (symbol->string x))
            ((number? x)
              (number->string x))
            ((char? x)
              (char->string x))
            ((string? x)
              (if readable
                  (string-append "\"" (quote-string x) "\"")
            ((null? x)
            ((pair? x)
              (if (and (pair? (cdr x))
                       (null? (cddr x)))
                  (case (car x)
                      (string-append "'" (to-string (cadr x))))
                      (string-append "`" (to-string (cadr x))))
                      (string-append "," (to-string (cadr x))))
                      (string-append ",@" (to-string (cadr x))))
                      (string-append "("
                                     (stringify-improper-list x #t)
                  (string-append "("
                                 (stringify-improper-list x #t)
            ((vector? x)
              (string-append "#" (to-string (vector->list x))))
            ((procedure? x)
            ((input-port? x)
              "#<input port>")
            ((output-port? x)
              "#<output port>")
            ((eof-object? x)

    (to-string x)))

(define write-to-string (make-string-writer #t))

(define display-to-string (make-string-writer #f))

contact  |  privacy