cs: fix interaction of error-print-with and prop:custom-write

Closes #3108

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

@@ -312,6 +312,20 @@
   (test "ab" format "~.a" "ab")
   (test 3 error-print-width))
 
+(parameterize ([error-print-width 3])
+  (struct show-a ()
+    #:property prop:custom-write
+    (lambda (self port mode)
+      (fprintf port "a")))
+  (struct show-nothing ()
+    #:property prop:custom-write
+    (lambda (self port mode)
+      (void)))
+  (test "a" format "~e" (show-a))
+  (test "..." format "~e" (list (show-a)))
+  (test "" format "~e" (show-nothing))
+  (test "'()" format "~e" (list (show-nothing))))
+
 ;; ----------------------------------------
 ;; make sure +inf.0 is ok for `print-syntax-width':
 (parameterize ([print-syntax-width +inf.0])

racket/src/io/port/max-output-port.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "../common/class.rkt"
          "../host/thread.rkt"
+         "../print/more-pending.rkt"
          "output-port.rkt"
          "bytes-output.rkt")
 
@@ -10,22 +11,34 @@
 (class max-output-port #:extends core-output-port
   #:field
   [o #f]
-  [max-length 0]
+  [max-length 0] ;; see "../print/write-with-max.rkt"
   #:override
   [write-out
    (lambda (src-bstr src-start src-end nonblock? enable-break? copy?)
      (cond
        [max-length
         (define len (- src-end src-start))
-        (unless (eq? max-length 'full)
+        (cond
-          (define write-len (min len max-length))
+          [(eq? max-length 'full)
-          (end-atomic)
+           ;; all consumed
-          (define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len)))
+           len]
-          (start-atomic)
+          [(pair? max-length)
-          (if (= max-length wrote-len)
+           (set! max-length (more-pending max-length src-start src-end src-bstr))
-              (set! max-length 'full)
+           ;; all consumed
-              (set! max-length (- max-length wrote-len))))
+           len]
-        len]
+          [else
+           (define write-len (min len max-length))
+           (end-atomic)
+           (define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len)))
+           (start-atomic)
+           (cond
+             [(= max-length wrote-len)
+              (set! max-length (more-pending '(0 . #"") (+ src-start max-length) src-end src-bstr))
+              ;; all consumed
+              len]
+             [else
+              (set! max-length (- max-length wrote-len))
+              wrote-len])])]
        [else
         (end-atomic)
         (define len (write-bytes src-bstr o src-start src-end))

racket/src/io/print/more-pending.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+(require "../string/convert.rkt")
+
+(provide more-pending)
+
+;; See "write-with-max.rkt"
+
+;; might be called in atomic mode
+(define (more-pending max-length start end str)
+  (define prev-pending (car max-length))
+  (define len (- end start))
+  (define new-pending (+ len prev-pending))
+  (cond
+    [(new-pending . > . 3) 'full]
+    [else (cons new-pending
+                (bytes-append (cdr max-length)
+                              (if (string? str)
+                                  (string->bytes/utf-8 str #f start end)
+                                  (subbytes str start end))))]))

racket/src/io/print/write-with-max.rkt

@@ -3,7 +3,7 @@
          "../port/bytes-output.rkt"
          "../port/port.rkt"
          "../port/max-output-port.rkt"
-         "../string/convert.rkt")
+         "more-pending.rkt")
 
 (provide write-string/max
          write-bytes/max
@@ -11,6 +11,12 @@
          make-output-port/max
          output-port/max-max-length)
 
+;; A `max-length` is either
+;;   #f => no limit
+;;   <n> => can still write <n> more characters
+;;   'full => can't write any more
+;;   (cons <n> <bytes>) => pending bytes that may be replaced by "..."
+
 (define (write-string/max str o max-length [start 0] [end (string-length str)])
   (cond
    [(eq? max-length 'full) 'full]
@@ -48,18 +54,6 @@
       (write-bytes bstr o start (+ start max-length))
       (more-pending '(0 . #"") (+ start max-length) end bstr)])]))
 
-(define (more-pending max-length start end str)
-  (define prev-pending (car max-length))
-  (define len (- end start))
-  (define new-pending (+ len prev-pending))
-  (cond
-    [(new-pending . > . 3) 'full]
-    [else (cons new-pending
-                (bytes-append (cdr max-length)
-                              (if (string? str)
-                                  (string->bytes/utf-8 str #f start end)
-                                  (subbytes str start end))))]))
-
 (define (make-output-port/max o max-length)
   (make-max-output-port o max-length))