Now change box/c to use proxies or chaperones appropriately.

Create a mzlib/contract compatible version of the old box/c and use that
for mzlib/contract.  Change the docs so that the docs for mzlib/contract
contain the right information.

Fix the typed-scheme implementation to only force flat box (or hash)
contracts when it already is required to be flat.  Otherwise, allow
non-flat contracts for the element contract (or domain/range contracts).

collects/mzlib/contract.rkt

@@ -23,6 +23,13 @@
 (require "private/contract-define.rkt")
 (provide (all-from-out "private/contract-define.rkt"))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; old-style flat mutable contracts
+;;
+(require "private/contract-mutable.rkt")
+(provide (all-from-out "private/contract-mutable.rkt"))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; provide everything from the racket/ implementation
@@ -30,8 +37,6 @@
 ;;
 
 (require racket/contract/private/base
-         racket/contract/private/box
-         racket/contract/private/hash
          racket/contract/private/misc
          racket/contract/private/provide
          racket/contract/private/guts
@@ -46,8 +51,6 @@
              contract-struct)
  
  (all-from-out racket/contract/private/base)
- (all-from-out racket/contract/private/box)
- (all-from-out racket/contract/private/hash)
  (all-from-out racket/contract/private/provide)
  (except-out (all-from-out racket/contract/private/misc)
              check-between/c

collects/mzlib/private/contract-mutable.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+
+(require (only-in racket/contract/private/box box-immutable/c)
+         racket/contract/private/blame
+         racket/contract/private/guts)
+
+(provide box/c box-immutable/c)
+
+(define/subexpression-pos-prop (box/c ctc)
+  (let ([ctc (coerce-flat-contract 'box/c ctc)])
+    (make-flat-contract
+     #:name (build-compound-type-name 'box/c ctc)
+     #:first-order
+     (λ (val)
+       (and (box? val)
+            (contract-first-order-passes? ctc (unbox val))))
+     #:projection
+     (λ (blame)
+       (λ (val)
+         (let ([proj ((contract-projection ctc) blame)])
+           (unless (box? val)
+             (raise-blame-error blame val "not a box"))
+           (proj (unbox val))
+           val))))))

collects/mzlib/scribblings/contract.scrbl

@@ -47,7 +47,6 @@ from @schememodname[scheme/contract]:
  any/c
  between/c
  box-immutable/c
- box/c
  build-compound-type-name
  coerce-contract
  cons/c
@@ -90,7 +89,7 @@ from @schememodname[scheme/contract]:
  vector/c
  vectorof]
 
-It also provides the old version of @scheme[define/contract]:
+It also provides the old version of the following forms:
 
 @defform[(define/contract id contract-expr init-value-expr)]{
 
@@ -109,3 +108,8 @@ provided by @scheme[provide/contract], because
 where the reference to the defined variable occurs. Instead, it uses
 the source location of the reference to the variable as the name of
 that definition.}
+
+@defproc[(box/c [c flat-contract?]) flat-contract?]{
+
+Returns a flat contract that recognizes boxes. The content of the box
+must match @racket[c].}

collects/racket/contract/private/box.rkt

@@ -3,7 +3,8 @@
 (require (for-syntax racket/base)
          "guts.rkt")
 
-(provide box-immutable/c box/c)
+(provide box-immutable/c 
+         (rename-out [build-box/c box/c]))
 
 (define-syntax (*-immutable/c stx)
   (syntax-case stx ()
@@ -87,12 +88,104 @@
 
 (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
 
-(define/final-prop (box/c pred)
+(define-struct box/c (content immutable))
-  (let* ([ctc (coerce-flat-contract 'box/c pred)]
+
-         [p? (flat-contract-predicate ctc)])
+(define (box/c-first-order ctc)
-    (build-flat-contract
+  (let ([elem-ctc (box/c-content ctc)]
-     (build-compound-type-name 'box/c ctc)
+        [immutable (box/c-immutable ctc)]
-     (λ (x)
+        [flat? (flat-box/c? ctc)])
-       (and (box? x)
+    (λ (val #:blame [blame #f])
-            (p? (unbox x)))))))
+      (let/ec return
+        (define (fail . args)
+          (if blame
+              (apply raise-blame-error blame val args)
+              (return #f)))
+        (unless (box? val)
+          (fail "expected a box, got ~a" val))
+        (case immutable
+          [(#t)
+           (unless (immutable? val)
+             (fail "expected an immutable box, got ~a" val))]
+          [(#f)
+           (when (immutable? val)
+             (fail "expected a mutable box, got ~a" val))]
+          [(dont-care) (void)])
+        (when (or flat? (and (immutable? val) (not blame)))
+          (if blame
+              (begin (((contract-projection elem-ctc) blame) (unbox val))
+                     (void))
+              (unless (contract-first-order-passes? elem-ctc (unbox val))
+                (fail))))))))
+
+(define (box/c-name ctc)
+  (let ([elem-name (contract-name (box/c-content ctc))]
+        [immutable (box/c-immutable ctc)]
+        [flat? (flat-box/c? ctc)])
+    (apply build-compound-type-name
+           'box/c
+           elem-name
+           (if (and flat? (eq? immutable #t))
+               (list '#:immutable #t)
+               (append
+                (if (not (eq? immutable 'dont-care))
+                    (list '#:immutable immutable)
+                    null)
+                (if flat?
+                    (list '#:flat? #t)
+                    null))))))
+
+(define-struct (flat-box/c box/c) ()
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name box/c-name
+   #:first-order box/c-first-order
+   #:projection
+   (λ (ctc)
+     (λ (blame)
+       (λ (val)
+         ((box/c-first-order ctc) val #:blame blame)
+         val)))))
+
+(define (ho-projection box-wrapper)
+  (λ (ctc)
+    (let ([elem-ctc (box/c-content ctc)]
+          [immutable (box/c-immutable ctc)])
+      (λ (blame)
+        (let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
+              [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
+          (λ (val)
+            ((box/c-first-order ctc) val #:blame blame)
+            (if (immutable? val)
+                (box-immutable (pos-elem-proj (unbox val)))
+                (box-wrapper val
+                             (λ (b v) (pos-elem-proj v))
+                             (λ (b v) (neg-elem-proj v))))))))))
+
+(define-struct (chaperone-box/c box/c) ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:name box/c-name
+   #:first-order box/c-first-order
+   #:projection (ho-projection chaperone-box)))
+
+(define-struct (proxy-box/c box/c) ()
+  #:property prop:contract
+  (build-contract-property
+   #:name box/c-name
+   #:first-order box/c-first-order
+   #:projection (ho-projection proxy-box)))
+
+(define (build-box/c elem #:immutable [immutable 'dont-care] #:flat? [flat? #f])
+  (let ([ctc (if flat?
+                 (coerce-flat-contract 'box/c elem)
+                 (coerce-contract 'box/c elem))])
+    (cond
+      [(or flat?
+           (and (eq? immutable #t)
+                (flat-contract? ctc)))
+       (make-flat-box/c ctc immutable)]
+      [(chaperone-contract? ctc)
+       (make-chaperone-box/c ctc immutable)]
+      [else
+       (make-proxy-box/c ctc immutable)])))
 

collects/tests/racket/contract-test.rktl

@@ -8886,6 +8886,30 @@ so that propagation occurs.
       (hash/c proxy-ctc proxy-ctc))
    exn:fail?)
   
+  (ctest #t contract?           (box/c number? #:flat? #t))
+  (ctest #t chaperone-contract? (box/c number? #:flat? #t))
+  (ctest #t flat-contract?      (box/c number? #:flat? #t))
+
+  (ctest #t contract?           (box/c number? #:immutable #t))
+  (ctest #t chaperone-contract? (box/c number? #:immutable #t))
+  (ctest #t flat-contract?      (box/c number? #:immutable #t))
+
+  (ctest #t contract?           (box/c number?))
+  (ctest #t chaperone-contract? (box/c number?))
+  (ctest #f flat-contract?      (box/c number?))
+
+  (ctest #t contract?           (box/c (box/c number?) #:immutable #t))
+  (ctest #t chaperone-contract? (box/c (box/c number?) #:immutable #t))
+  (ctest #f flat-contract?      (box/c (box/c number?) #:immutable #t))
+
+  (ctest #t contract?           (box/c (-> number? number?)))
+  (ctest #f chaperone-contract? (box/c (-> number? number?)))
+  (ctest #f flat-contract?      (box/c (-> number? number?)))
+
+  (ctest #t contract?           (box/c (-> number? number?) #:immutable #t))
+  (ctest #f chaperone-contract? (box/c (-> number? number?) #:immutable #t))
+  (ctest #f flat-contract?      (box/c (-> number? number?) #:immutable #t))
+
   (ctest #t contract? 1)
   (ctest #t contract? (-> 1 1))
   
@@ -8978,8 +9002,10 @@ so that propagation occurs.
   (test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) (list 1 #f))
   (test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) #f)
 
-  (test-flat-contract '(box/c boolean?) (box #f) (box 1))
+  (test-flat-contract '(box/c boolean? #:flat? #t) (box #f) (box 1))
-  (test-flat-contract '(box/c (flat-contract boolean?)) (box #t) #f)
+  (test-flat-contract '(box/c (flat-contract boolean?) #:flat? #t) (box #t) #f)
+  (test-flat-contract '(box-immutable/c boolean?) (box-immutable #f) (box-immutable 1))
+  (test-flat-contract '(box-immutable/c (flat-contract boolean?)) (box-immutable #t) #f)
   
   (test-flat-contract '(flat-rec-contract sexp (cons/c sexp sexp) number?) '(1 2 . 3) '(1 . #f))
   (test-flat-contract '(flat-murec-contract ([even1 (or/c null? (cons/c number? even2))] 

collects/typed-scheme/private/type-contract.rkt

@@ -134,7 +134,9 @@
         [(Vector: t)
          #`(vectorof #,(t->c t #:flat #t))]
         [(Box: t)
-         #`(box/c #,(t->c t #:flat #t))]
+         (if flat?
+             #`(box/c #,(t->c t #:flat #t) #:flat? #t)
+             #`(box/c #,(t->c t)))]
         [(Pair: t1 t2)
          #`(cons/c #,(t->c t1) #,(t->c t2))]
         [(Opaque: p? cert)
@@ -206,7 +208,10 @@
         [(Syntax: t) #`(syntax/c #,(t->c t))]
         [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
         [(Param: in out) #`(parameter/c #,(t->c out))]
-	[(Hashtable: k v) #`(hash/c #,(t->c k #:flat #t) #,(t->c v #:flat #t) #:immutable 'dont-care)]
+	[(Hashtable: k v) 
+         (if flat?
+             #`(hash/c #,(t->c k #:flat #t) #,(t->c v #:flat #t) #:flat? #t #:immutable 'dont-care)
+             #`(hash/c #,(t->c k) #,(t->c v) #:immutable 'dont-care))]
         [else          
          (exit (fail))]))))