From b478201674f606758ddc15213c29ce44adabea33 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 29 Jan 2017 19:12:05 -0800
Subject: [PATCH] Change string printer to generate R7RS-compatible strings.

---
 src/runtime/unpars.scm | 77 +++++++++++++++++-------------------------
 1 file changed, 31 insertions(+), 46 deletions(-)

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 9d2990514..df5a65d5b 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -31,7 +31,7 @@ USA.
 
 (define hook/interned-symbol)
 (define hook/procedure-unparser)
-(define string-delimiters)
+(define string-quoted)
 (define non-canon-symbol-quoted)
 (define canon-symbol-quoted)
 (define system-global-unparser-table)
@@ -75,8 +75,8 @@ USA.
 (define (initialize-package!)
   (set! hook/interned-symbol unparse-symbol)
   (set! hook/procedure-unparser #f)
-  (set! string-delimiters
-        (char-set-union char-set:not-graphic (char-set #\" #\\)))
+  (set! string-quoted
+        (char-set-union char-set:not-graphic (char-set #\\ #\" #\|)))
   (set! non-canon-symbol-quoted
         (char-set-union char-set/atom-delimiters char-set/symbol-quotes))
   (set! canon-symbol-quoted
@@ -534,7 +534,7 @@ USA.
 
 (define (unparse/character character)
   (if (or (param:slashify?)
-          (not (char-ascii? character)))
+          (not (ascii-char? character)))
       (begin
         (*unparse-string "#\\")
         (*unparse-string (char->name character #t)))
@@ -542,51 +542,36 @@ USA.
 
 (define (unparse/string string)
   (if (param:slashify?)
-      (let ((end (ustring-length string)))
-        (let ((end*
-               (let ((limit (get-param:unparser-string-length-limit)))
-                 (if limit
-                     (min limit end)
-                     end))))
+      (let* ((end (ustring-length string))
+	     (end*
+	      (let ((limit (get-param:unparser-string-length-limit)))
+		(if limit
+		    (min limit end)
+		    end))))
           (*unparse-char #\")
-          (if (ustring-find-first-char-in-set string string-delimiters 0 end*)
-              (let loop ((start 0))
-                (let ((index
-                       (ustring-find-first-char-in-set string string-delimiters
-						       start end*)))
-                  (if index
-                      (begin
-                        (*unparse-substring string start index)
-                        (*unparse-char #\\)
-                        (let ((char (ustring-ref string index)))
-                          (cond ((char=? char char:newline)
-                                 (*unparse-char #\n))
-                                ((char=? char #\tab)
-                                 (*unparse-char #\t))
-                                ((char=? char #\vt)
-                                 (*unparse-char #\v))
-                                ((char=? char #\bs)
-                                 (*unparse-char #\b))
-                                ((char=? char #\return)
-                                 (*unparse-char #\r))
-                                ((char=? char #\page)
-                                 (*unparse-char #\f))
-                                ((char=? char #\bel)
-                                 (*unparse-char #\a))
-                                ((or (char=? char #\\)
-                                     (char=? char #\"))
-                                 (*unparse-char char))
-                                (else
-				 (*unparse-char #\x)
-				 (*unparse-string
-				  (number->string (char->integer char) 16))
-				 (*unparse-char #\;))))
-                        (loop (+ index 1)))
-                      (*unparse-substring string start end*))))
-              (*unparse-substring string 0 end*))
+	  (do ((index 0 (fix:+ index 1)))
+	      ((not (fix:< index end*)))
+	    (if (fix:< index end)
+		(let ((char (ustring-ref string index)))
+		  (if (char-set-member? string-quoted char)
+		      (begin
+			(*unparse-char #\\)
+			(case char
+			  ((#\bel) (*unparse-char #\a))
+			  ((#\bs) (*unparse-char #\b))
+			  ((#\tab) (*unparse-char #\t))
+			  ((#\newline) (*unparse-char #\n))
+			  ((#\return) (*unparse-char #\r))
+			  ((#\\ #\" #\|) (*unparse-char char))
+			  (else
+			   (*unparse-char #\x)
+			   (*unparse-string
+			    (number->string (char->integer char) 16))
+			   (*unparse-char #\;))))
+		      (*unparse-char char)))))
           (if (< end* end)
               (*unparse-string "..."))
-          (*unparse-char #\")))
+          (*unparse-char #\"))
       (*unparse-string string)))
 
 (define (unparse/bit-string bit-string)
-- 
2.25.1