>From 11520831798b489cb16f3eb0ec3d3de3ca579b14 Mon Sep 17 00:00:00 2001
From: Florian Zumbiehl <address@hidden>
Date: Tue, 5 Mar 2013 18:48:58 +0100
Subject: [PATCH 2/3] extras/pretty-print: escape control characters in strings

Make pretty-print encode control characters in strings as escape sequences
rather than as literal bytes, the same way write does it.

Signed-off-by: Peter Bex <address@hidden>
---
 extras.scm        | 62 +++++++++++++++++++++++++++++++++----------------------
 tests/pp-test.scm |  3 ++-
 2 files changed, 39 insertions(+), 26 deletions(-)

diff --git a/extras.scm b/extras.scm
index 0e8b144..f6daf1c 100644
--- a/extras.scm
+++ b/extras.scm
@@ -331,31 +331,43 @@
 	       (##sys#print obj #t s)
 	       (out (get-output-string s) col) ) )
 	    ((procedure? obj)   (out (##sys#procedure->string obj) col))
-	    ((string? obj)      (if display?
-				    (out obj col)
-				    (let loop ((i 0) (j 0) (col (out "\"" col)))
-				      (if (and col (fx< j (string-length obj)))
-					  (let ((c (string-ref obj j)))
-                                            (if (or (char=? c #\\)
-                                                    (char=? c #\"))
-                                                (loop j
-                                                      (+ j 1)
-                                                      (out "\\"
-                                                           (out (##sys#substring obj i j)
-                                                                col)))
-                                                (cond ((assq c '((#\tab . "\\t")
-                                                                 (#\newline . "\\n")
-                                                                 (#\return . "\\r")))
-                                                       =>
-                                                       (lambda (a)
-                                                         (let ((col2
-                                                                (out (##sys#substring obj i j) col)))
-                                                           (loop (fx+ j 1)
-                                                                 (fx+ j 1)
-                                                                 (out (cdr a) col2)))))
-                                                      (else (loop i (fx+ j 1) col)))))
-					  (out "\""
-					       (out (##sys#substring obj i j) col))))))
+	    ((string? obj)
+             (if display?
+		 (out obj col)
+		 (let loop ((i 0) (j 0) (col (out "\"" col)))
+		   (if (and col (fx< j (string-length obj)))
+		       (let ((c (string-ref obj j)))
+			 (cond
+			  ((or (char=? c #\\)
+			       (char=? c #\"))
+			   (loop j
+				 (+ j 1)
+				 (out "\\"
+				      (out (##sys#substring obj i j)
+					   col))))
+			  ((or (char<? c #\x20)
+			       (char=? c #\x7f))
+			   (loop (fx+ j 1)
+				 (fx+ j 1)
+				 (let ((col2
+					(out (##sys#substring obj i j) col)))
+				   (cond ((assq c '((#\tab . "\\t")
+						    (#\newline . "\\n")
+						    (#\return . "\\r")
+						    (#\vtab . "\\v")
+						    (#\page . "\\f")
+						    (#\alarm . "\\a")
+						    (#\backspace . "\\b")))
+					  =>
+					  (lambda (a)
+					    (out (cdr a) col2)))
+					 (else
+					  (out (number->string (char->integer c) 16)
+					       (out (if (char<? c #\x10) "0" "")
+						    (out "\\x" col2))))))))
+			  (else (loop i (fx+ j 1) col))))
+		       (out "\""
+			    (out (##sys#substring obj i j) col))))))
 	    ((char? obj)        (if display?
 				    (out (make-string 1 obj) col)
 				    (let ([code (char->integer obj)])
diff --git a/tests/pp-test.scm b/tests/pp-test.scm
index 318c982..0af80e4 100644
--- a/tests/pp-test.scm
+++ b/tests/pp-test.scm
@@ -13,4 +13,5 @@
 (test "\"\\\\\\\"\"\n" (pp->string "\\\""))
 (test "\"\\\\\\\\\\\\\\\"\"\n" (pp->string "\\\\\\\""))
 (test "\"\\\"\\\"\\\"\"\n" (pp->string "\"\"\""))
-(test "\\" "\\")
+(test "\"\\n\\t\\r\\b\\a\\v\\f\"\n" (pp->string "\n\t\r\b\a\v\f"))
+(test "\\" "\\")                        ; XXX?
-- 
1.8.0.1