moved out the syntax->string function

svn: r1085

collects/slideshow/code.ss

@@ -2,7 +2,8 @@
 (module code "slideshow.ss"
   (require (lib "code.ss" "texpict")
 	   (lib "unitsig.ss"))
-  (require-for-syntax (lib "list.ss"))
+  (require-for-syntax (lib "to-string.ss" "syntax")
+                      (lib "list.ss"))
 
   (define-values/invoke-unit/sig code^
     code@
@@ -95,70 +96,6 @@
              empty
              l))
 
-    (define (to-string c)
-      (let* ([s (open-output-string)]
-	     [l (syntax->list c)]
-	     [init-col (or (syntax-column (first l)) 0)]
-	     [col init-col]
-	     [line (or (syntax-line (first l)) 0)])
-	(define (advance c init-line!)
-	  (let ([c (syntax-column c)]
-		[l (syntax-line c)])
-	    (when (and l (l . > . line))
-	      (newline)
-	      (set! line l)
-	      (init-line!))
-	    (when c
-	      (display (make-string (max 0 (- c col)) #\space))
-	      (set! col c))))
-	(parameterize ([current-output-port s]
-		       [read-case-sensitive #t])
-	  (define (loop init-line!)
-	    (lambda (c)
-	      (cond
-	       [(eq? 'code:blank (syntax-e c))
-		(advance c init-line!)]
-	       [(eq? '_ (syntax-e c)) (void)]
-	       [(eq? '... (syntax-e c))
-		(void)]
-	       [(and (pair? (syntax-e c))
-		     (eq? (syntax-e (car (syntax-e c))) 'code:comment))
-		(advance c init-line!)
-		(printf "; ")
-		(display (syntax-e (cadr (syntax->list c))))]
-	       [(and (pair? (syntax-e c))
-		     (eq? (syntax-e (car (syntax-e c))) 'code:contract))
-		(advance c init-line!)
-		(printf "; ")
-		(let* ([l (cdr (syntax->list c))]
-		       [s-col (or (syntax-column (first l)) col)])
-		  (set! col s-col)
-		  (for-each (loop (lambda ()
-				    (set! col s-col)
-				    (printf "; ")))
-			    l))]
-	       [(and (pair? (syntax-e c))
-		     (eq? (syntax-e (car (syntax-e c))) 'quote))
-		(advance c init-line!)
-		(printf "'")
-		(let ([i (cadr (syntax->list c))])
-		  (set! col (or (syntax-column i) col))
-		  ((loop init-line!) i))]
-	       [(pair? (syntax-e c))
-		(advance c init-line!)
-		(printf "(")
-		(set! col (+ col 1))
-		(map (loop init-line!) (syntax->list c))
-		(printf ")")
-		(set! col (+ col 1))]
-	       [else
-		(advance c init-line!)
-		(let ([s (format "~s" (syntax-e c))])
-		  (set! col (+ col (string-length s)))
-		  (display s))])))
-	  (for-each (loop (lambda () (set! col init-col))) l))
-	(get-output-string s)))
-    
     (syntax-case stx ()
       [(_ s (showable-name runnable-name string-name) . c)
        #`(begin
@@ -172,7 +109,7 @@
 	       #,@(drop-to-show (syntax->list #'c)))
 	      s))
 	   (define string-name
-	     #,(to-string #'c)))]))
+	     #,(syntax->string #'c)))]))
 
   (define-syntax define-exec-code
     (syntax-rules ()

collects/syntax/doc.txt

@@ -525,3 +525,11 @@ less powerful code inspector to a sub-program should generally attach
 the class system work properly.
 
 
+======================================================================
+_to-string.ss_: rendering syntax objects with formatting
+======================================================================
+
+> (syntax->string stx-list) - builds a string with newlines
+  and indenting according to the source locations in stx-list
+
+  the outer pair of parens are not rendered from stx-list.

collects/syntax/to-string.ss

@@ -0,0 +1,72 @@
+(module to-string mzscheme
+  (require (lib "contract.ss")
+           (lib "stx.ss" "syntax"))
+  
+  (provide/contract [syntax->string (-> (and/c syntax? stx-list?)
+                                        string?)])
+  
+  (require (lib "list.ss"))
+
+  (define (syntax->string c)
+    (let* ([s (open-output-string)]
+           [l (syntax->list c)]
+           [init-col (or (syntax-column (first l)) 0)]
+           [col init-col]
+           [line (or (syntax-line (first l)) 0)])
+      (define (advance c init-line!)
+        (let ([c (syntax-column c)]
+              [l (syntax-line c)])
+          (when (and l (l . > . line))
+            (newline)
+            (set! line l)
+            (init-line!))
+          (when c
+            (display (make-string (max 0 (- c col)) #\space))
+            (set! col c))))
+      (parameterize ([current-output-port s]
+                     [read-case-sensitive #t])
+        (define (loop init-line!)
+          (lambda (c)
+            (cond
+              [(eq? 'code:blank (syntax-e c))
+               (advance c init-line!)]
+              [(eq? '_ (syntax-e c)) (void)]
+              [(eq? '... (syntax-e c))
+               (void)]
+              [(and (pair? (syntax-e c))
+                    (eq? (syntax-e (car (syntax-e c))) 'code:comment))
+               (advance c init-line!)
+               (printf "; ")
+               (display (syntax-e (cadr (syntax->list c))))]
+              [(and (pair? (syntax-e c))
+                    (eq? (syntax-e (car (syntax-e c))) 'code:contract))
+               (advance c init-line!)
+               (printf "; ")
+               (let* ([l (cdr (syntax->list c))]
+                      [s-col (or (syntax-column (first l)) col)])
+                 (set! col s-col)
+                 (for-each (loop (lambda ()
+                                   (set! col s-col)
+                                   (printf "; ")))
+                           l))]
+              [(and (pair? (syntax-e c))
+                    (eq? (syntax-e (car (syntax-e c))) 'quote))
+               (advance c init-line!)
+               (printf "'")
+               (let ([i (cadr (syntax->list c))])
+                 (set! col (or (syntax-column i) col))
+                 ((loop init-line!) i))]
+              [(pair? (syntax-e c))
+               (advance c init-line!)
+               (printf "(")
+               (set! col (+ col 1))
+               (map (loop init-line!) (syntax->list c))
+               (printf ")")
+               (set! col (+ col 1))]
+              [else
+               (advance c init-line!)
+               (let ([s (format "~s" (syntax-e c))])
+                 (set! col (+ col (string-length s)))
+                 (display s))])))
+        (for-each (loop (lambda () (set! col init-col))) l))
+      (get-output-string s))))