cs: fix some printer problems exposed by "print.rktl" tests

pkgs/racket-test-core/tests/racket/print.rktl

@@ -139,6 +139,8 @@
   (ptest "'(#<procedure:add1>)" (list add1))
   (ptest "'#(#<procedure:add1>)" (vector add1))
 
+  (ptest "(arity-at-least 1)" (arity-at-least 1))
+
   (ptest "#0='(#0#)" (read (open-input-string "#0=(#0#)")))
   (ptest "#0='(#0# #0#)" (read (open-input-string "#0=(#0# #0#)")))
   (ptest "#0='(#0# . #0#)" (read (open-input-string "#0=(#0# . #0#)")))
@@ -261,12 +263,12 @@
   ;; path value in compiled code => path appears in .zo format:
   (let ([o (open-output-string)])
     (write (compile p) o)
-    (test #t regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))
+    (test #t 'path-in-code?1 (regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))))
   ;; `current-write-relative-directory' set => path not in .zo format: 
   (let ([o (open-output-string)])
     (parameterize ([current-write-relative-directory (current-directory)])
       (write (compile p) o)
-    (test #f regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))))
+    (test #f 'path-in-code?2 (regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))))
   ;; try all possible supers that have at least two path elements:
   (let loop ([super (current-directory)])
     (let ([super (let-values ([(base name dir?) (split-path super)])
@@ -279,12 +281,12 @@
         (let ([o (open-output-string)])
           (parameterize ([current-write-relative-directory (current-directory)])
             (write (compile (build-path super "other")) o)
-            (test #t regexp-match? (regexp-quote (path->bytes super)) (get-output-string o))))
+            (test #t 'path-in-code?3 (regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))))
         (let ([o (open-output-string)])
           (parameterize ([current-write-relative-directory (cons (current-directory)
                                                                  super)])
             (write (compile (build-path super "other")) o)
-            (test #f regexp-match? (regexp-quote (path->bytes super)) (get-output-string o))))
+            (test #f 'path-in-code?4 (regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))))
         (loop super)))))
 
 ;; ----------------------------------------

racket/src/io/demo.rkt

@@ -279,9 +279,9 @@
                      void)))
 (port-count-lines! specialist)
 
-(test '(special #f #f #f #f) (read-byte-or-special specialist))
+(test '(special #f 1 0 1) (read-byte-or-special specialist))
 (test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src))
-(test '(special #f #f #f #f) (peek-byte-or-special specialist))
+(test '(special #f 1 2 3) (peek-byte-or-special specialist))
 (test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src))
 (test 'special (peek-byte-or-special specialist 0 #f 'special 'src))
 (test 'special (peek-char-or-special specialist 0 'special 'src))
@@ -603,13 +603,24 @@
   (print-test b "#0='#&#0#"))
 
 (let ([b (vector #f #f)])
+  (struct p (x y) #:transparent)
   (vector-set! b 0 b)
   (vector-set! b 1 b)
   (print-test b "#0='#(#0# #0#)")
   (print-test '(1) "'(1)")
   (print-test (cons 1 (cons 2 3)) "'(1 2 . 3)")
   (print-test (cons 1 (cons 2 (mcons 3 4))) "(cons 1 (cons 2 (mcons 3 4)))")
-  (print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))"))
+  (print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))")
+  (print-test '('a) "'('a)")
+  (print-test '(4 . 'a) "'(4 . 'a)")
+  (print-test '(4 unquote a) "'(4 . ,a)")
+  (print-test '(4 unquote @a) "'(4 . , @a)")
+  (print-test '#(4 unquote a) "'#(4 unquote a)")
+  (print-test '((quote a b)) "'((quote a b))")
+  (print-test (p 1 2) "(p 1 2)")
+  (print-test (box (p 1 2)) "(box (p 1 2))")
+  (print-test (hasheq 1 (p 1 2) 2 'other) "(hasheq 1 (p 1 2) 2 'other)")
+  )
 
 (let ([b (make-hash)])
   (hash-set! b 'self b)

racket/src/io/print/graph.rkt

@@ -58,8 +58,7 @@
       [(and (struct? v)
             (config-get config print-struct))
        (and (not print-graph?)
-            (or (not (eq? mode PRINT-MODE/UNQUOTED))
+            (prefab-struct-key v) ; can quote a prefab in `print` mode
-                (prefab-struct-key v)) ; can quote a prefab in `print` mode
             (quick-no-graph? (struct->vector v) (sub1 fuel)))]
       [else fuel])))
 

racket/src/io/print/list.rkt

@@ -1,7 +1,10 @@
 #lang racket/base
 (require "write-with-max.rkt"
          "mode.rkt"
-         "graph.rkt")
+         "graph.rkt"
+         "config.rkt"
+         "parameter.rkt"
+         "symbol.rkt")
 
 (provide print-list)
 
@@ -10,6 +13,32 @@
     (and (eq? mode PRINT-MODE/UNQUOTED)
          (not alt-list-constructor)
          (not (uninterrupted-list? v graph))))
+  (define (abbreviation v)
+    (and (eq? mode PRINT-MODE/QUOTED)
+         (pair? v)
+         (pair? (cdr v))
+         (null? (cddr v))
+         (not alt-list-constructor)
+         (config-get config print-reader-abbreviations)
+         (let ([starts-@? (lambda (v)
+                            (and (symbol? v)
+                                 (let ([s (symbol->print-string v #:config config)])
+                                   (char=? #\@ (string-ref s 0)))))])
+           (case (car v)
+             [(quote) "'"]
+             [(quasiquote) "`"]
+             [(unquote) (if (starts-@? (cadr v)) ", " ",")]
+             [(unquote-splicing) ",@"]
+             [(syntax) "#'"]
+             [(quasisyntax) "#`"]
+             [(unsyntax) (if (starts-@? (cadr v)) "#, " "#,")]
+             [(unsyntax-splicing) "#,@"]
+             [else #f]))))
+  (cond
+    [(abbreviation v)
+     => (lambda (prefix)
+          (p who (cadr v) mode o (write-string/max prefix o max-length) graph config))]
+    [else
      (let ([max-length
             (cond
               [(eq? mode PRINT-MODE/UNQUOTED)
@@ -31,16 +60,21 @@
               (write-string/max ")" o max-length))]
            [(and (pair? (cdr v))
                  (or (not graph) (non-graph? (hash-ref graph (cdr v) #f)))
-              (not unquoted-pairs?))
+                 (not unquoted-pairs?)
+                 (not (abbreviation (cdr v))))
             (let ([max-length (p who (car v) mode o max-length graph config)])
               (loop (cdr v) (write-string/max " " o max-length)))]
+           [(abbreviation v)
+            => (lambda (prefix)
+                 ;; Assume a "." has already printed
+                 (p who (cadr v) mode o (write-string/max prefix o max-length) graph config))]
            [else
             (let* ([max-length (p who (car v) mode o max-length graph config)]
                    [max-length (if unquoted-pairs?
                                    (write-string/max " " o max-length)
                                    (write-string/max " . " o max-length))]
                    [max-length (p who (cdr v) mode o max-length graph config)])
-           (write-string/max ")" o max-length))]))))
+              (write-string/max ")" o max-length))])))]))
 
 (define (uninterrupted-list? v graph)
   (and (list? v)

racket/src/io/print/main.rkt

@@ -224,9 +224,13 @@
        [(eq? mode DISPLAY-MODE) (write-string/max (string v) o max-length)]
        [else (print-char v o max-length)])]
     [(not v)
-     (write-string/max "#f" o max-length)]
+     (if (config-get config print-boolean-long-form)
+         (write-string/max "#false" o max-length)
+         (write-string/max "#f" o max-length))]
     [(eq? v #t)
-     (write-string/max "#t" o max-length)]
+     (if (config-get config print-boolean-long-form)
+         (write-string/max "#true" o max-length)
+         (write-string/max "#t" o max-length))]
     [(pair? v)
      (print-list p who v mode o max-length graph config #f #f)]
     [(vector? v)
@@ -238,25 +242,40 @@
      (define l (for/list ([e (in-fxvector v)]) e))
      (print-list p who l mode o max-length graph config "#fx(" "(fxvector")]
     [(box? v)
-     (if (config-get config print-box)
+     (cond
-         (p who (unbox v) mode o (write-string/max "#&" o max-length) graph config)
+       [(config-get config print-box)
-         (write-string/max "#<box>" o max-length))]
+        (cond
+          [(eq? mode PRINT-MODE/UNQUOTED)
+           (let* ([max-length (write-string/max "(box " o max-length)]
+                  [max-length (p who (unbox v) mode o max-length graph config)])
+             (write-string/max ")" o max-length))]
+          [else
+           (p who (unbox v) mode o (write-string/max "#&" o max-length) graph config)])]
+       [else
+        (check-unreadable who config mode v)
+        (write-string/max "#<box>" o max-length)])]
     [(hash? v)
-     (if (and (config-get config print-hash-table)
+     (cond
+       [(and (config-get config print-hash-table)
              (not (hash-weak? v)))
-         (print-hash v o max-length p who mode graph config)
+        (cond
-         (write-string/max "#<hash>" o max-length))]
+          [(eq? mode PRINT-MODE/UNQUOTED)
+           (define l (apply append (hash-map v list #t)))
+           (define prefix (cond
+                            [(hash-eq? v) "(hasheq"]
+                            [(hash-eqv? v) "(hasheqv"]
+                            [else "(hash"]))
+           (print-list p who l mode o max-length graph config #f prefix)]
+          [else
+           (print-hash v o max-length p who mode graph config)])]
+       [else
+        (check-unreadable who config mode v)
+        (write-string/max "#<hash>" o max-length)])]
     [(and (eq? mode WRITE-MODE)
           (not (config-get config print-unreadable))
           ;; Regexps are a special case: custom writers that produce readable input
           (not (printable-regexp? v)))
-     (raise (exn:fail
+     (fail-unreadable who v)]
-             (string-append (symbol->string who)
-                            ": printing disabled for unreadable value"
-                            "\n  value: "
-                            (parameterize ([print-unreadable #t])
-                              ((error-value->string-handler) v (error-print-width))))
-             (current-continuation-marks)))]
     [(mpair? v)
      (print-mlist p who v mode o max-length graph config)]
     [(custom-write? v)
@@ -295,6 +314,22 @@
      (print-named "input-port" v mode o max-length)]
     [(core-output-port? v)
      (print-named "output-port" v mode o max-length)]
+    [(unquoted-printing-string? v)
+     (write-string/max (unquoted-printing-string-value v) o max-length)]
     [else
      ;; As a last resort, fall back to the host `format`:
      (write-string/max (format "~s" v) o max-length)]))
+
+(define (fail-unreadable who v)
+  (raise (exn:fail
+          (string-append (symbol->string who)
+                         ": printing disabled for unreadable value"
+                         "\n  value: "
+                         (parameterize ([print-unreadable #t])
+                           ((error-value->string-handler) v (error-print-width))))
+          (current-continuation-marks))))
+
+(define (check-unreadable who config mode v)
+  (when (and (eq? mode WRITE-MODE)
+             (not (config-get config print-unreadable)))
+    (fail-unreadable who v)))