diff --git a/collects/images/compile-time.rkt b/collects/images/compile-time.rkt
index d9857f3903..34210c57f9 100644
--- a/collects/images/compile-time.rkt
+++ b/collects/images/compile-time.rkt
@@ -1,33 +1,103 @@
 #lang racket/base
 
-(require (for-syntax racket/base racket/class racket/draw)
+(require (for-syntax racket/base
+                     racket/class racket/draw racket/math)
          racket/class racket/draw)
 
 (provide compiled-bitmap compiled-bitmap-list)
 
-(define-for-syntax (make-3d-bitmap ctxt bm)
-  (define p (open-output-bytes))
-  (send bm save-file p 'png)
-  (with-syntax ([bs  (datum->syntax ctxt (get-output-bytes p))])
-    (syntax/loc ctxt
-      (make-object bitmap% (open-input-bytes bs) 'png/alpha))))
+(begin-for-syntax
+  (define (save-png bm)
+    (define p (open-output-bytes))
+    (send bm save-file p 'png)
+    (define bs (get-output-bytes p))
+    ;(printf "Wrote PNG: ~v bytes~n" (bytes-length bs))
+    bs)
+  
+  (define (save-jpeg bm quality)
+    (define w (send bm get-width))
+    (define h (send bm get-height))
+    (define bs (make-bytes (* 4 w h)))
+    
+    (send bm get-argb-pixels 0 0 w h bs #t)
+    (for ([i  (in-range 0 (* 4 w h) 4)])
+      (define a (bytes-ref bs i))
+      (bytes-set! bs i 255)
+      (bytes-set! bs (+ i 1) a)
+      (bytes-set! bs (+ i 2) a)
+      (bytes-set! bs (+ i 3) a))
+    
+    (define alpha-bm (make-bitmap w h #f))
+    (send alpha-bm set-argb-pixels 0 0 w h bs)
+    (define alpha-p (open-output-bytes))
+    (send alpha-bm save-file alpha-p 'jpeg quality)
+    
+    (send bm get-argb-pixels 0 0 w h bs #f)
+    (define rgb-bm (make-bitmap w h #f))
+    (send rgb-bm set-argb-pixels 0 0 w h bs #f)
+    (define rgb-p (open-output-bytes))
+    (send rgb-bm save-file rgb-p 'jpeg quality)
+    
+    (define alpha-bs (get-output-bytes alpha-p))
+    (define rgb-bs (get-output-bytes rgb-p))
+    ;(printf "Wrote JPEG: ~v bytes~n" (+ (bytes-length alpha-bs) (bytes-length rgb-bs)))
+    
+    (values alpha-bs rgb-bs))
+  
+  (define (make-3d-bitmap ctxt bm quality)
+    (cond [(= quality 100)
+           (with-syntax ([bs  (datum->syntax ctxt (save-png bm))])
+             (syntax/loc ctxt (load-png bs)))]
+          [else
+           (define-values (alpha-bs rgb-bs) (save-jpeg bm quality))
+           (with-syntax ([alpha-bs  (datum->syntax ctxt alpha-bs)]
+                         [rgb-bs    (datum->syntax ctxt rgb-bs)])
+             (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs)))]))
+  )
+
+(define (load-png bs)
+  (read-bitmap (open-input-bytes bs) 'png/alpha))
+
+(define (load-jpeg alpha-bs rgb-bs)
+  (define alpha-bm (read-bitmap (open-input-bytes alpha-bs) 'jpeg))
+  (define rgb-bm (read-bitmap (open-input-bytes rgb-bs) 'jpeg))
+  (define w (send rgb-bm get-width))
+  (define h (send rgb-bm get-height))
+  
+  (define new-bs (make-bytes (* 4 w h)))
+  (send rgb-bm get-argb-pixels 0 0 w h new-bs #f)
+  
+  (define bs (make-bytes (* 4 w h)))
+  (send alpha-bm get-argb-pixels 0 0 w h bs #f)
+  (for ([i  (in-range 0 (* 4 w h) 4)])
+    (define a (bytes-ref bs (+ i 2)))
+    (bytes-set! new-bs i a))
+  
+  (define new-bm (make-bitmap w h))
+  (send new-bm set-argb-pixels 0 0 w h new-bs #f)
+  new-bm)
 
 (define-syntax (compiled-bitmap stx)
   (syntax-case stx ()
-    [(_ expr)  (syntax/loc stx
-                 (let-syntax ([maker  (λ (inner-stx)
-                                        (define bm expr)
-                                        (unless (is-a? bm bitmap%)
-                                          (raise-syntax-error
-                                           'compiled-bitmap
-                                           (format "expected argument of type <bitmap%>; given ~e" bm)
-                                           #'expr))
-                                        (make-3d-bitmap inner-stx bm))])
-                   (maker)))]))
+    [(_ expr)
+     (syntax/loc stx (compiled-bitmap expr 100))]
+    [(_ expr quality)
+     (syntax/loc stx
+       (let-syntax ([maker  (λ (inner-stx)
+                              (define bm expr)
+                              (unless (is-a? bm bitmap%)
+                                (raise-syntax-error
+                                 'compiled-bitmap
+                                 (format "expected argument of type <bitmap%>; given ~e" bm)
+                                 #'expr))
+                              (make-3d-bitmap inner-stx bm quality))])
+         (maker)))]))
 
 (define-syntax (compiled-bitmap-list stx)
   (syntax-case stx ()
     [(_ expr)
+     (syntax/loc stx (compiled-bitmap-list expr 100))]
+    [(_ expr quality)
      (syntax/loc stx
        (let-syntax ([maker  (λ (inner-stx)
                               (define bms expr)
@@ -37,6 +107,6 @@
                                  (format "expected argument of type <list of bitmap%>; given ~e" bms)
                                  #'expr))
                               (with-syntax ([(bm (... ...))
-                                             (map (λ (e) (make-3d-bitmap inner-stx e)) bms)])
+                                             (map (λ (e) (make-3d-bitmap inner-stx e quality)) bms)])
                                 #'(list bm (... ...))))])
          (maker)))]))
diff --git a/collects/images/logos.rkt b/collects/images/logos.rkt
index 6a576484c0..22409ea1a6 100644
--- a/collects/images/logos.rkt
+++ b/collects/images/logos.rkt
@@ -150,13 +150,14 @@
                 lambda-fm)]
           [fm  (flomap-cc-superimpose
                 (draw-icon-flomap
-                 256 256 (λ (dc)
-                           (send dc set-pen "lightblue" 2 'solid)
-                           (send dc set-brush "white" 'transparent)
-                           (send dc draw-ellipse 7 7 242 242)
-                           (send dc set-pen lambda-outline-color 4 'solid)
-                           (send dc draw-ellipse 2 2 252 252))
-                 scale)
+                 32 32 (λ (dc)
+                         (send dc set-pen lambda-outline-color 1/2 'solid)
+                         (send dc set-brush "white" 'solid)
+                         (draw-ellipse/smoothed dc -0.25 -0.25 32.5 32.5)
+                         (send dc set-pen "lightblue" 1/2 'solid)
+                         (send dc set-brush "white" 'transparent)
+                         (draw-ellipse/smoothed dc 0.5 0.5 31 31))
+                 (/ height 32))
                 fm)])
      fm)))
 
@@ -288,11 +289,12 @@
    (flomap-cc-superimpose
     (draw-icon-flomap
      32 32 (λ (dc)
+             (send dc set-pen lambda-outline-color 1/2 'solid)
+             (send dc set-brush "white" 'solid)
+             (draw-ellipse/smoothed dc -0.25 -0.25 32.5 32.5)
              (send dc set-pen "lightblue" 1/2 'solid)
              (send dc set-brush "white" 'transparent)
-             (send dc draw-ellipse 0.5 0.5 31 31)
-             (send dc set-pen lambda-outline-color 1/2 'solid)
-             (send dc draw-ellipse -0.25 -0.25 32.5 32.5))
+             (draw-ellipse/smoothed dc 0.5 0.5 31 31))
      scale)
     earth-fm
     land-fm)))
@@ -332,10 +334,12 @@
         -28 4 -44 12 -60 32))
    1/8 1/8))
 
+(define racket-r-outline-color (make-object color% 64 16 16))
+
 (define (racket-r-flomap color height)
   (draw-icon-flomap
    32 32 (λ (dc)
-           (set-icon-pen dc lambda-outline-color 3/8 'solid)
+           (set-icon-pen dc racket-r-outline-color 3/8 'solid)
            (send dc set-brush color 'solid)
            (draw-path-commands dc racket-r-commands 0 0))
    (/ height 32)))
@@ -352,9 +356,9 @@
    [height]
    (define scale (/ height 32))
    (define sphere-fm
-     (let* ([indent-fm  (racket-r-flomap lambda-outline-color height)]
+     (let* ([indent-fm  (racket-r-flomap racket-r-outline-color height)]
             [indent-dfm  (flomap->deep-flomap indent-fm)]
-            [indent-dfm  (deep-flomap-raise indent-dfm (* -1.5 scale))]
+            [indent-dfm  (deep-flomap-raise indent-dfm (* -0.75 scale))]
             [indent-dfm  (deep-flomap-smooth-z indent-dfm (* 0.5 scale))]
             [sphere-fm  (draw-icon-flomap
                          32 32 (λ (dc)
@@ -373,14 +377,12 @@
                          scale)]
             [sphere-dfm  (flomap->deep-flomap sphere-fm)]
             [sphere-dfm  (deep-flomap-bulge-spheroid sphere-dfm (* 14 scale))]
-            [sphere-dfm  (deep-flomap-raise sphere-dfm (* 0 scale))]
             [sphere-dfm  (deep-flomap-cc-superimpose 'add sphere-dfm indent-dfm)])
        (deep-flomap-render-icon sphere-dfm glass-logo-material)))
    
    (define r-fm
      (let* ([r-fm  (racket-r-flomap light-metal-icon-color height)]
             [r-dfm  (flomap->deep-flomap r-fm)]
-            ;[r-dfm  (deep-flomap-emboss r-dfm (* 2 scale) (* 8 scale))]
             [r-dfm  (deep-flomap-bulge-round r-dfm (* 48 scale))]
             [r-dfm  (deep-flomap-smooth-z r-dfm (* 1/2 scale))])
        (deep-flomap-render-icon r-dfm metal-material)))
@@ -388,11 +390,12 @@
    (flomap-cc-superimpose
     (draw-icon-flomap
      32 32 (λ (dc)
+             (send dc set-pen racket-r-outline-color 1/2 'solid)
+             (send dc set-brush "white" 'solid)
+             (draw-ellipse/smoothed dc -0.25 -0.25 32.5 32.5)
              (send dc set-pen "lightblue" 1/2 'solid)
              (send dc set-brush "white" 'transparent)
-             (send dc draw-ellipse 0.5 0.5 31 31)
-             (send dc set-pen lambda-outline-color 1/2 'solid)
-             (send dc draw-ellipse -0.25 -0.25 32.5 32.5))
+             (draw-ellipse/smoothed dc 0.5 0.5 31 31))
      scale)
     sphere-fm
     r-fm)))
diff --git a/collects/images/private/flomap-effects.rkt b/collects/images/private/flomap-effects.rkt
index d0222bc49b..cee5b9129d 100644
--- a/collects/images/private/flomap-effects.rkt
+++ b/collects/images/private/flomap-effects.rkt
@@ -1,16 +1,18 @@
 #lang typed/racket/base
 
-(require racket/flonum
+(require racket/flonum racket/math racket/match racket/list
          (except-in racket/fixnum fl->fx fx->fl)
-         racket/match racket/list
          "flonum.rkt"
          "flomap-struct.rkt"
          "flomap-pointwise.rkt"
          "flomap-blur.rkt"
-         "flomap-composite.rkt")
+         "flomap-composite.rkt"
+         "flomap-resize.rkt"
+         "flomap-transform.rkt")
 
 (provide flomap-outline flomap-outlined
-         flomap-shadow flomap-shadowed)
+         flomap-shadow flomap-shadowed
+         flomap-whirl-morph)
 
 (: colorize-alpha (flomap (Listof Real) -> flomap))
 (define (colorize-alpha fm color)
@@ -65,3 +67,37 @@
   (case-lambda
     [(fm amt)    (flomap-outlined fm amt #f)]
     [(fm amt c)  (flomap-cc-superimpose (flomap-outline fm amt c) fm)]))
+
+(define blend-start 1/3)
+(define blend-end 2/3)
+
+(: flomap-whirl-morph (flomap flomap -> (Real -> flomap)))
+(define (flomap-whirl-morph fm1 fm2)
+  (define w (max (flomap-width fm1) (flomap-width fm2)))
+  (define h (max (flomap-height fm1) (flomap-height fm2)))
+  (let ([fm1  (flomap-crop fm1 w h 1/2 1/2)]
+        [fm2  (flomap-crop fm2 w h 1/2 1/2)])
+    
+    (define: (whirled-fm1 [t : Real]) : flomap
+      (define t1 (sqr t))
+      (define trans1
+        (transform-compose (whirl-and-pinch-transform (* t1 (* -8 pi)) (* -4 t1) 1)
+                           (rotate-transform (* t1 (* -1 pi)))))
+      (flomap-transform fm1 trans1 0 w 0 h))
+    
+    (define: (whirled-fm2 [t : Real]) : flomap
+      (define t2 (sqr (- 1 t)))
+      (define trans2
+        (transform-compose (rotate-transform (* t2 (* 1 pi)))
+                           (whirl-and-pinch-transform (* t2 (* 8 pi)) (* -4 t2) 1)))
+      (flomap-transform fm2 trans2 0 w 0 h))
+    
+    (λ (t)
+      (cond [(t . <= . 0)  fm1]
+            [(t . >= . 1)  fm2]
+            [else
+             (cond [(t . <= . blend-start)  (whirled-fm1 t)]
+                   [(t . >= . blend-end)    (whirled-fm2 t)]
+                   [else
+                    (define b (/ (- t blend-start) (- blend-end blend-start)))
+                    (fm+ (fm* (- 1 b) (whirled-fm1 t)) (fm* b (whirled-fm2 t)))])]))))
diff --git a/collects/images/private/flomap-struct.rkt b/collects/images/private/flomap-struct.rkt
index 8d38544f24..2c85b871aa 100644
--- a/collects/images/private/flomap-struct.rkt
+++ b/collects/images/private/flomap-struct.rkt
@@ -53,24 +53,28 @@
 (: flomap-bilinear-ref (flomap Integer Real Real -> Flonum))
 (define (flomap-bilinear-ref fm k x y)
   (match-define (flomap vs c w h) fm)
-  (unless (and (k . >= . 0) (k . < . c))
-    (raise-type-error 'flomap-bilinear-ref (format "nonnegative fixnum < ~e" c) k))
-  (let ([x  (- (exact->inexact x) 0.5)]
-        [y  (- (exact->inexact y) 0.5)])
-    (define floor-x (floor x))
-    (define floor-y (floor y))
-    (define x0 (fl->fx floor-x))
-    (define y0 (fl->fx floor-y))
-    (define x1 (fx+ x0 1))
-    (define y1 (fx+ y0 1))
-    (define v00 (unsafe-flomap-ref vs c w h k x0 y0))
-    (define v10 (unsafe-flomap-ref vs c w h k x1 y0))
-    (define v01 (unsafe-flomap-ref vs c w h k x0 y1))
-    (define v11 (unsafe-flomap-ref vs c w h k x1 y1))
-    (define xα (- x floor-x))
-    (fl-convex-combination (fl-convex-combination v00 v10 xα)
-                           (fl-convex-combination v01 v11 xα)
-                           (- y floor-y))))
+  (cond [(and (k . >= . 0) (k . < . c))
+         (let ([x  (- (exact->inexact x) 0.5)]
+               [y  (- (exact->inexact y) 0.5)])
+           (cond [(and (x . > . -0.5) (x . < . (+ 0.5 (fx->fl w)))
+                       (y . > . -0.5) (y . < . (+ 0.5 (fx->fl h))))
+                  (define floor-x (floor x))
+                  (define floor-y (floor y))
+                  (define x0 (fl->fx floor-x))
+                  (define y0 (fl->fx floor-y))
+                  (define x1 (fx+ x0 1))
+                  (define y1 (fx+ y0 1))
+                  (define v00 (unsafe-flomap-ref vs c w h k x0 y0))
+                  (define v10 (unsafe-flomap-ref vs c w h k x1 y0))
+                  (define v01 (unsafe-flomap-ref vs c w h k x0 y1))
+                  (define v11 (unsafe-flomap-ref vs c w h k x1 y1))
+                  (define xα (- x floor-x))
+                  (fl-convex-combination (fl-convex-combination v00 v10 xα)
+                                         (fl-convex-combination v01 v11 xα)
+                                         (- y floor-y))]
+                 [else  0.0]))]
+        [else
+         (raise-type-error 'flomap-bilinear-ref (format "nonnegative fixnum < ~e" c) 1 fm k x y)]))
 
 ;; ===================================================================================================
 ;; Construction and conversion
diff --git a/collects/images/private/flomap-transform.rkt b/collects/images/private/flomap-transform.rkt
index 9022162d56..b3487a4a78 100644
--- a/collects/images/private/flomap-transform.rkt
+++ b/collects/images/private/flomap-transform.rkt
@@ -1,15 +1,15 @@
 #lang typed/racket/base
 
-(require racket/flonum
+(require racket/match racket/math racket/flonum
          (except-in racket/fixnum fl->fx fx->fl)
-         racket/match
          "flonum.rkt"
          "flomap-struct.rkt")
 
 (provide flomap-flip-horizontal flomap-flip-vertical flomap-transpose
          flomap-cw-rotate flomap-ccw-rotate
-         invertible-2d-function Flomap-Transform
-         flomap-transform rotate-transform
+         (struct-out invertible-2d-function) Flomap-Transform
+         transform-compose rotate-transform whirl-and-pinch-transform
+         flomap-transform 
          )
 
 (: flomap-flip-horizontal (flomap -> flomap))
@@ -47,6 +47,17 @@
 
 (define-type Flomap-Transform (Integer Integer -> invertible-2d-function))
 
+(: transform-compose (Flomap-Transform Flomap-Transform -> Flomap-Transform))
+(define ((transform-compose t1 t2) w h)
+  (match-define (invertible-2d-function f1 g1) (t1 w h))
+  (match-define (invertible-2d-function f2 g2) (t2 w h))
+  (invertible-2d-function (λ: ([x : Flonum] [y : Flonum])
+                            (let-values ([(x y)  (f2 x y)])
+                              (f1 x y)))
+                          (λ: ([x : Flonum] [y : Flonum])
+                            (let-values ([(x y)  (g1 x y)])
+                              (g2 x y)))))
+
 (: flomap-transform (case-> (flomap Flomap-Transform -> flomap)
                             (flomap Flomap-Transform Real Real Real Real -> flomap)))
 (define flomap-transform
@@ -70,7 +81,7 @@
                   (x-loop (fx+ x 1))]
                  [else
                   (y-loop (fx+ y 1))]))))
-     (flomap-transform fm t (- x-min 0.5) (+ x-max 0.5) (- y-min 0.5) (+ y-max 0.5))]
+     (flomap-transform fm t x-min x-max y-min y-max)]
     [(fm t x-min x-max y-min y-max)
      (let ([x-min  (exact->inexact x-min)]
            [x-max  (exact->inexact x-max)]
@@ -111,3 +122,52 @@
              [y  (- y y-mid)])
          (values (+ x-mid (+ (* x cos-θ) (* y sin-θ)))
                  (+ y-mid (- (* y cos-θ) (* x sin-θ)))))))))
+
+(: flexpt (Flonum Flonum -> Flonum))
+(define (flexpt b x)
+  (exp (* x (fllog b))))
+
+(: whirl-and-pinch-function (Real Real Real Integer Integer
+                                  -> (Flonum Flonum -> (values Flonum Flonum))))
+(define (whirl-and-pinch-function θ pinch radius w h)
+  (let ([θ  (exact->inexact θ)]
+        [pinch  (- (exact->inexact pinch))]
+        [radius  (exact->inexact radius)])
+    (define pinch-exp
+      (cond [(pinch . >= . 0.0)  pinch]
+            [else  (/ pinch (- 1.0 pinch))]))
+    (define x-mid (* 0.5 (fx->fl w)))
+    (define y-mid (* 0.5 (fx->fl h)))
+    (define-values (x-scale y-scale)
+      (cond [(x-mid . < . y-mid)  (values (/ y-mid x-mid) 1.0)]
+            [(x-mid . > . y-mid)  (values 1.0 (/ x-mid y-mid))]
+            [else  (values 1.0 1.0)]))
+    (define fm-radius (* 0.5 (fx->fl (max w h))))
+    (define fm-radius^2 (* radius (sqr fm-radius)))
+    (define x-max (+ 0.5 (fx->fl w)))
+    (define y-max (+ 0.5 (fx->fl h)))
+    (λ: ([x : Flonum] [y : Flonum])
+      (define dx (* (- x x-mid) x-scale))
+      (define dy (* (- y y-mid) y-scale))
+      (define r^2 (+ (sqr dx) (sqr dy)))
+      (cond [(r^2 . < . fm-radius^2)
+             (define r (flsqrt (/ r^2 fm-radius^2)))
+             (define factor (cond [(or (r . = . 0.0) (pinch . = . 0.0))  1.0]
+                                  [else  (flexpt r pinch-exp)]))
+             (define pinched-dx (* dx factor))
+             (define pinched-dy (* dy factor))
+             (define ang (* θ (sqr (- 1.0 r))))
+             (define cos-a (cos ang))
+             (define sin-a (sin ang))
+             (define old-x (+ (/ (- (* pinched-dx cos-a) (* pinched-dy sin-a)) x-scale) x-mid))
+             (define old-y (+ (/ (+ (* pinched-dx sin-a) (* pinched-dy cos-a)) y-scale) y-mid))
+             (values (max -0.5 (min x-max old-x))
+                     (max -0.5 (min y-max old-y)))]
+            [else
+             (values x y)]))))
+
+(: whirl-and-pinch-transform (Real Real Real -> Flomap-Transform))
+(define ((whirl-and-pinch-transform θ pinch radius) w h)
+  (invertible-2d-function
+   (whirl-and-pinch-function (- θ) (- pinch) radius w h)
+   (whirl-and-pinch-function θ pinch radius w h)))
diff --git a/collects/images/private/flonum.rkt b/collects/images/private/flonum.rkt
index 7396fcf080..18284861aa 100644
--- a/collects/images/private/flonum.rkt
+++ b/collects/images/private/flonum.rkt
@@ -18,10 +18,13 @@
 (: unsafe-flvector-set! (FlVector Integer Flonum -> Void))
 (define unsafe-flvector-set! flvector-set!)
 
-(define-syntax-rule (fl->fx x)
-  (let ([i  (fl->exact-integer x)])
-    (with-asserts ([i  fixnum?])
-      i)))
+(define-syntax (fl->fx stx)
+  (syntax-case stx ()
+    [(_ x)
+     (syntax/loc stx
+       (let ([i  (fl->exact-integer x)])
+         (with-asserts ([i  fixnum?])
+           i)))]))
 
 (define-syntax-rule (fx->fl i)
   (->fl i))
diff --git a/collects/images/scribblings/compile-time.scrbl b/collects/images/scribblings/compile-time.scrbl
index aa9f96f9af..4f797fbadb 100644
--- a/collects/images/scribblings/compile-time.scrbl
+++ b/collects/images/scribblings/compile-time.scrbl
@@ -24,15 +24,21 @@ To reduce the startup time of programs that use computed bitmaps, use the macros
 The macros defined here compute bitmaps at expansion time, and expand to the bitmap's @racket[bytes] and a simple wrapper that converts @racket[bytes] to a @racket[bitmap%].
 Thus, fully expanded, compiled modules contain (more or less) literal bitmap values, which do not need to be computed again when the module is @racket[require]d by another.
 
-The literal bitmap values are encoded in @link["http://en.wikipedia.org/wiki/Portable_Network_Graphics"]{PNG} format, so they are compressed in the compiled module.
+The literal bitmap values are encoded in @link["http://en.wikipedia.org/wiki/Portable_Network_Graphics"]{PNG} or @link["http://en.wikipedia.org/wiki/JPEG"]{JPEG} format, so they are compressed in the compiled module.
 
 To get the most from compiled bitmaps during development, it is best to put them in files that are changed infrequently.
 For example, for games, we suggest having a separate module called something like @tt{images.rkt} or @tt{resources.rkt} that @racket[provide]s all the game's images.
 
-@defform[(compiled-bitmap expr)]{
+@defform[(compiled-bitmap expr [quality])]{
 Evaluates @racket[expr] at expansion time, which must return a @racket[bitmap%], and returns to the bitmap at run time.
 Keep in mind that @racket[expr] has access only to expansion-time values, not run-time values.
 
+If @racket[quality] is @racket[100], the bitmap is stored as a PNG.
+If @racket[quality] is between @racket[0] and @racket[99] inclusive, it is stored as a JPEG with quality @racket[quality].
+(See @method[bitmap% save-file].)
+If the bitmap has an alpha channel, its alpha channel is stored as a separate JPEG.
+The default value is @racket[100].
+
 Generally, to use this macro, wrap a @racket[bitmap%]-producing expression with it and move any identifiers it depends on into the expansion phase.
 For example, suppose we are computing a large PLT logo at run time:
 @codeblock|{#lang racket}|
@@ -58,8 +64,9 @@ Note that @racketmodname[images/logos] is now required @racket[for-syntax], so t
 has access to the identifier @racket[plt-logo].
 }
 
-@defform[(compiled-bitmap-list expr)]{
+@defform[(compiled-bitmap-list expr [quality])]{
 Like @racket[compiled-bitmap], but it expects @racket[expr] to return a @racket[list] of @racket[bitmap%]s, and it returns the list at run time.
+The @racket[quality] argument works as in @racket[compiled-bitmap], but is applied to all the images in the list.
 
 Use this for animations. For example,
 @codeblock|{#lang racket}|
@@ -73,7 +80,8 @@ Use this for animations. For example,
 (define running-stickman-frames
   (compiled-bitmap-list
    (for/list ([t  (in-range 0 1 (/ 1 num-stickman-frames))])
-     (running-stickman-icon t "red" "white" "red" 32))))
+     (running-stickman-icon t "red" "white" "red" 32))
+   50))
 ]
 This computes
 @interaction[#:eval ctime-eval running-stickman-frames]
diff --git a/collects/images/tests/effects-tests.rkt b/collects/images/tests/effects-tests.rkt
new file mode 100644
index 0000000000..9e59d171c5
--- /dev/null
+++ b/collects/images/tests/effects-tests.rkt
@@ -0,0 +1,63 @@
+#lang racket/gui
+
+(require images/gui
+         images/compile-time
+         (for-syntax racket/math
+                     images/private/flomap
+                     images/logos)
+         images/private/flomap
+         images/logos)
+
+(define frame-delay 1/30)
+
+(begin-for-syntax
+  (define size 256)
+  (define blur 8)
+  (define frame-num 10)
+  (define end-frame-quality 90)
+  (define mid-frame-quality 35)
+  
+  (define background-fm (make-flomap/components size size '(1 1 1 1)))
+  
+  (define plt-fm
+    (flomap-shadowed (flomap-inset (plt-flomap (- size (* 4 blur))) (* 2 blur))
+                     blur '(0 0 0.1)))
+  
+  (define racket-fm
+    (flomap-shadowed (flomap-inset (racket-flomap (- size (* 4 blur))) (* 2 blur))
+                     blur '(0.1 0 0)))
+  
+  (define logo-flomap* (flomap-whirl-morph plt-fm racket-fm))
+  
+  (define (logo-flomap t)
+    (flomap-cc-superimpose background-fm (logo-flomap* t))))
+
+(define logo-frames
+  (time
+   (append (list (compiled-bitmap (time (flomap->bitmap (logo-flomap 0)))
+                                  end-frame-quality))
+           (compiled-bitmap-list
+            (time
+             (for/list ([t  (in-range 1 frame-num)])
+               (flomap->bitmap (logo-flomap (/ t frame-num)))))
+            mid-frame-quality)
+           (list (compiled-bitmap (time (flomap->bitmap (logo-flomap 1)))
+                                  end-frame-quality)))))
+
+(define frame (new frame% [label "Whirl Morph Logo"] [width 256] [height 256]))
+(define canvas (make-object bitmap-canvas% frame (first logo-frames)))
+(send frame show #t)
+
+(for ([_  (in-range 5)])
+  (for ([frame  (in-list logo-frames)])
+    (send canvas set-bitmap frame)
+    (send canvas refresh)
+    (sleep/yield frame-delay))
+  (sleep 1)
+  (for ([frame  (in-list (reverse logo-frames))])
+    (send canvas set-bitmap frame)
+    (send canvas refresh)
+    (sleep/yield frame-delay))
+  (sleep 1))
+
+(send frame show #f)
diff --git a/collects/meta/props b/collects/meta/props
index 734568d116..aad9355dd4 100755
--- a/collects/meta/props
+++ b/collects/meta/props
@@ -970,6 +970,7 @@ path/s is either such a string or a list of them.
 "collects/icons/private/mkheart.rkt" drdr:command-line #f
 "collects/icons/private/svg/render-png.rkt" drdr:command-line #f
 "collects/images" responsible (ntoronto)
+"collects/images/tests/effects-tests.rkt" drdr:command-line #f
 "collects/lang" responsible (mflatt robby matthias)
 "collects/lang/htdp-langs.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/lang/plt-pretty-big.rkt" drdr:command-line (gracket-text "-t" *)