Initially just move the box-related combinators to a new location.

collects/mzlib/contract.rkt

@@ -30,6 +30,7 @@
 ;;
 
 (require racket/contract/private/base
+         racket/contract/private/box
          racket/contract/private/hash
          racket/contract/private/misc
          racket/contract/private/provide
@@ -45,6 +46,7 @@
              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)

collects/racket/contract/base.rkt

@@ -6,6 +6,7 @@
 (require "private/arrow.rkt"
          "private/arr-i.rkt"
          "private/base.rkt"
+         "private/box.rkt"
          "private/hash.rkt"
          "private/misc.rkt"
          "private/provide.rkt"
@@ -26,6 +27,7 @@
              check-procedure/more
              make-contracted-function)
  (all-from-out "private/arr-i.rkt")
+ (all-from-out "private/box.rkt")
  (all-from-out "private/hash.rkt")
  (except-out (all-from-out "private/misc.rkt")
              check-between/c

collects/racket/contract/private/box.rkt

@@ -0,0 +1,98 @@
+#lang racket/base
+
+(require (for-syntax racket/base)
+         "guts.rkt")
+
+(provide box-immutable/c box/c)
+
+(define-syntax (*-immutable/c stx)
+  (syntax-case stx ()
+    [(_ predicate? constructor (arb? selectors ...) type-name name)
+     #'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)]
+    [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?)
+     (and (eq? #f (syntax->datum (syntax arb?)))
+          (boolean? (syntax->datum #'test-immutable?)))
+     (let ([test-immutable? (syntax->datum #'test-immutable?)])
+       (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(procs ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
+         #`(let ([predicate?-name predicate?]
+                 [constructor-name constructor]
+                 [selector-names selectors] ...)
+             (λ (params ...)
+               (let ([ctc-x (coerce-contract 'name params)] ...)
+                 (if (and (flat-contract? ctc-x) ...)
+                     (let ([p-apps (flat-contract-predicate ctc-x)] ...)
+                       (build-flat-contract
+                        `(name ,(contract-name ctc-x) ...)
+                        (lambda (x)
+                          (and (predicate?-name x)
+                               (p-apps (selector-names x)) 
+                               ...))))
+                     (let ([procs (contract-projection ctc-x)] ...)
+                       (make-contract
+                        #:name (build-compound-type-name 'name ctc-x ...)
+                        #:projection
+                        (λ (blame)
+                          (let ([p-apps (procs blame)] ...)
+                            (λ (v)
+                              (if #,(if test-immutable?
+                                        #'(and (predicate?-name v)
+                                               (immutable? v))
+                                        #'(predicate?-name v))
+                                  (constructor-name (p-apps (selector-names v)) ...)
+                                  (raise-blame-error
+                                   blame
+                                   v
+                                   #,(if test-immutable?
+                                         "expected immutable <~a>, given: ~e"
+                                         "expected <~a>, given: ~e")
+                                   'type-name
+                                   v)))))))))))))]
+    [(_ predicate? constructor (arb? selector) correct-size type-name name)
+     (eq? #t (syntax->datum (syntax arb?)))
+     (syntax
+      (let ([predicate?-name predicate?]
+            [constructor-name constructor]
+            [selector-name selector])
+        (λ params
+          (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
+            (let ([procs (map contract-projection ctcs)])
+              (make-contract
+               #:name (apply build-compound-type-name 'name ctcs)
+               #:projection
+               (λ (blame)
+                 (let ([p-apps (map (λ (proc) (proc blame)) procs)]
+                       [count (length params)])
+                   (λ (v)
+                     (if (and (immutable? v)
+                              (predicate?-name v)
+                              (correct-size count v))
+                         (apply constructor-name 
+                                (let loop ([p-apps p-apps]
+                                           [i 0])
+                                  (cond
+                                    [(null? p-apps) null]
+                                    [else (let ([p-app (car p-apps)])
+                                            (cons (p-app (selector-name v i))
+                                                  (loop (cdr p-apps) (+ i 1))))])))
+                         (raise-blame-error
+                          blame
+                          v
+                          "expected <~a>, given: ~e"
+                          'type-name
+                          v)))))))))))]))
+
+(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
+
+(define/final-prop (box/c pred)
+  (let* ([ctc (coerce-flat-contract 'box/c pred)]
+         [p? (flat-contract-predicate ctc)])
+    (build-flat-contract
+     (build-compound-type-name 'box/c ctc)
+     (λ (x)
+       (and (box? x)
+            (p? (unbox x)))))))
+

collects/racket/contract/private/misc.rkt

@@ -22,7 +22,6 @@
          symbols one-of/c
          listof non-empty-listof cons/c list/c
          vectorof vector-immutableof vector/c vector-immutable/c 
-         box-immutable/c box/c
          promise/c
          struct/c
          syntax/c
@@ -794,15 +793,6 @@
                     procs
                     (vector->list v)))))))
 
-(define/final-prop (box/c pred)
-  (let* ([ctc (coerce-flat-contract 'box/c pred)]
-         [p? (flat-contract-predicate ctc)])
-    (build-flat-contract
-     (build-compound-type-name 'box/c ctc)
-     (λ (x)
-       (and (box? x)
-            (p? (unbox x)))))))
-
 ;;
 ;; cons/c opter
 ;;
@@ -982,7 +972,6 @@
 
 (define cons/c-main-function (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
 (define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
-(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
 (define vector-immutable/c (*-immutable/c vector?
                                           vector-immutable
                                           (#t (λ (v i) (vector-ref v i)))

collects/scribblings/reference/contracts.scrbl

@@ -20,6 +20,7 @@ constraints.
 @note-lib[racket/contract #:use-sources (racket/contract/private/ds
                                          racket/contract/private/base
                                          racket/contract/private/guts
+                                         racket/contract/private/box
                                          racket/contract/private/hash
                                          racket/contract/private/misc
                                          racket/contract/private/provide)]